home *** CD-ROM | disk | FTP | other *** search
/ Reverse Code Engineering RCE CD +sandman 2000 / ReverseCodeEngineeringRceCdsandman2000.iso / RCE / Tools / Turbo Pascal V7 / TVFM.ZIP / FILECOPY.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-11-03  |  10.1 KB  |  402 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Vision File Manager Demo               }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. {$X+,V-,R-,S-}
  9.  
  10. unit FileCopy;
  11.  
  12. interface
  13.  
  14. uses Objects;
  15.  
  16. const
  17.  
  18.   { I/O error constants }
  19.   erWriteOpen  =  -1;  { error opening for Write }
  20.   erReadOpen   =  -2;  { error opening for read  }
  21.   erDiskFull   =  -3;  { error writing to file   }
  22.   erLostFile   =  -4;  { file never finished }
  23.   erNoFile     =  -5;  { file not found }
  24.   erRename     =  -6;  { Unable to rename }
  25.   erResetAFlag =  -7;  { Unable to reset archive flag on original file }
  26.  
  27.   { Internal error constants }
  28.   erOutOfMemory = -99;  { could not allocate more memory }
  29.  
  30.   { copy options }
  31.   coNormal     = $0000;   { normal copy }
  32.   coCopyAOnly  = $0001;   { copy file only if Archive bit is set }
  33.   coResetAFlag = $0002;   { reset Archive bit after succesful copy }
  34.  
  35. type
  36.  
  37.   erAction = (erAbort, erRetry);
  38.  
  39.   PFileCopy = ^TFileCopy;
  40.   TFileCopy = object(TObject)
  41.     Incomplete: Boolean;
  42.     IsNewFile: Boolean;
  43.     Offset: Longint;
  44.     Base: Longint;
  45.     FileList: PCollection;
  46.     Result: Integer;
  47.     Action: erAction;
  48.  
  49.     constructor Init(MaxFiles: Integer);
  50.     destructor Done; virtual;
  51.  
  52.     { reporting methods }
  53.     procedure ReadMsg(const FName: FNameStr; Progress: Longint); virtual;
  54.     procedure WriteMsg(const FName: FNameStr; Progress: Longint); virtual;
  55.     procedure ReportError(S: String); virtual;
  56.  
  57.     { copy and support methods }
  58.     function CopyFile(const SourceName, TargetName: FNameStr; Options: Word): Boolean;
  59.     procedure FlushBuffers;
  60.     procedure EraseByName(const FName: FNameStr);
  61.  
  62.     { error methods }
  63.     function IOError(const FName: FNameStr; ECode:Integer) : erAction; virtual;
  64.     function InternalError(ECode: Integer) : erAction; virtual;
  65.     function ErrorMsg(ECode: Integer) : String; virtual;
  66.   end;
  67.  
  68.  
  69. implementation
  70.  
  71. uses Dos;
  72.  
  73. const
  74.   fmReadOnly = 0;
  75.   fmReadWrite = 2;
  76.   MaxXFerSize = $F000; { largest block to read from disk }
  77.  
  78. type
  79.   String10 = String[10];
  80.  
  81.   { TPtrCollection implements a collection of pointers.  Instead of each  }
  82.   { entry in the collection pointing to a pointer, the entries themselves }
  83.   { are the actual pointers.                                              }
  84.  
  85.   PPtrCollection = ^TPtrCollection;
  86.   TPtrCollection = object(TCollection)
  87.     function GetItem(var S:TStream) : Pointer; virtual;
  88.     procedure PutItem(var S: TStream; Item: Pointer); virtual;
  89.     procedure FreeItem(Item:Pointer); virtual;
  90.   end;
  91.  
  92.   { PFileRec represents a single file that is being processed. }
  93.  
  94.   PFileRec = ^TFileRec;
  95.   TFileRec = object(TObject)
  96.     Filename: PString;
  97.     OrigName: PString;
  98.     FTime: Longint;
  99.     FSize: Longint;
  100.     Buffers: PPtrCollection;
  101.     Offset: Longint;
  102.     Create: Boolean;
  103.     OptFlags: Word;
  104.     constructor Init(OldName, NewName: FNameStr);
  105.     destructor Done; virtual;
  106.   end;
  107.  
  108.  
  109. { TPtrCollection }
  110.  
  111. function TPtrCollection.GetItem(var S: TStream): Pointer;
  112. var
  113.   P : Pointer;
  114. begin
  115.   S.Read(P, SizeOf(Pointer));
  116.   GetItem := P;
  117. end;
  118.  
  119. procedure TPtrCollection.PutItem(var S: TStream; Item: Pointer);
  120. begin
  121.   S.Write(Item, SizeOf(Pointer));
  122. end;
  123.  
  124. procedure TPtrCollection.FreeItem(Item:Pointer);
  125. begin
  126.   { do nothing }
  127. end;
  128.  
  129.  
  130. { TFileRec }
  131. constructor TFileRec.Init(OldName, NewName: FNameStr);
  132. begin
  133.   inherited Init;
  134.   Filename := NewStr(NewName);
  135.   OrigName := NewStr(OldName);
  136. end;
  137.  
  138. destructor TFileRec.Done;
  139. begin
  140.   DisposeStr(Filename);
  141.   DisposeStr(OrigName);
  142.   if Buffers <> nil then Dispose(Buffers, Done);
  143.   inherited Done;
  144. end;
  145.  
  146.  
  147. { TFileCopy }
  148. constructor TFileCopy.Init(MaxFiles: Integer);
  149. begin
  150.   inherited Init;
  151.   FileList := New(PCollection, Init(MaxFiles, MaxFiles div 2));
  152.   if Filelist = nil then
  153.   begin
  154.     ReportError(ErrorMsg(erOutOfMemory));
  155.     Fail;
  156.   end;
  157. end;
  158.  
  159. destructor TFileCopy.Done;
  160. begin
  161.   if FileList^.Count <> 0 then FlushBuffers;
  162.   if FileList <> nil then Dispose(FileList, Done);
  163.   inherited Done;
  164. end;
  165.  
  166. function TFileCopy.IOError(const FName: FNameStr; ECode: Integer): erAction;
  167. begin
  168.   ReportError(ErrorMsg(ECode));
  169.   IOError := erAbort;
  170. end;
  171.  
  172. function TFileCopy.InternalError(ECode: Integer): erAction;
  173. begin
  174.   ReportError(ErrorMsg(ECode));
  175.   InternalError := erAbort;
  176. end;
  177.  
  178. procedure TFileCopy.EraseByName(const FName: FNameStr);
  179. var
  180.   F: File;
  181.   I: Integer;
  182. begin
  183.   Assign(F, FName);
  184.   {$I-}
  185.   Reset(F);
  186.   {$I+}
  187.   if IOResult = 0 then Erase(F);
  188.   I := IOResult;   { read this so we don't leave any unused value there }
  189. end;
  190.  
  191. procedure TFileCopy.FlushBuffers;
  192. var
  193.   Leave : Integer;
  194.  
  195. procedure FlushFile(CurFile: PFileRec); far;
  196. var
  197.   BufAddr: Pointer;
  198.   BytesToXFer: Word;
  199.   BytesRead: Word;
  200.   TargetFile: File;
  201.   RemainingBytes: Longint;
  202.   Attr: Word;
  203. begin
  204.   FileMode := fmReadWrite;
  205.  
  206.   Action := erRetry;
  207.   Result := 1;
  208.   while (Action <> erAbort) and (Result <> 0) do
  209.   begin
  210.     Assign(TargetFile, CurFile^.FileName^);
  211.     {$I-}
  212.     if CurFile^.Create then Rewrite(TargetFile, 1)
  213.     else Reset(TargetFile, 1);
  214.     {$I+}
  215.     Result := IOResult;
  216.     if Result <> 0 then
  217.     begin
  218.       Action := IOError(CurFile^.FileName^, erWriteOpen);
  219.       if Action = erAbort then Exit;
  220.     end;
  221.   end;
  222.  
  223.   Seek(TargetFile, CurFile^.Offset);
  224.  
  225.   if (FileList^.IndexOf(CurFile) = FileList^.Count-1) and Incomplete
  226.     then Inc(Offset, CurFile^.FSize);
  227.  
  228.   RemainingBytes := CurFile^.FSize;
  229.  
  230.   repeat
  231.     if RemainingBytes > MaxXFerSize then BytesToXFer := MaxXFerSize
  232.     else BytesToXFer := RemainingBytes;
  233.     BufAddr := CurFile^.Buffers^.At(0);  { get first address }
  234.     BlockWrite(TargetFile, BufAddr^, BytesToXFer, BytesRead);
  235.     WriteMsg(CurFile^.Filename^, BytesRead);
  236.     Dec(RemainingBytes, BytesRead);
  237.     FreeMem(BufAddr, BytesToXFer);
  238.     CurFile^.Buffers^.AtDelete(0);
  239.   until RemainingBytes = 0;
  240.  
  241.   if not Incomplete then SetFTime(TargetFile, CurFile^.FTime);
  242.   Close(TargetFile);
  243.  
  244.   if ((FileList^.IndexOf(CurFile) <> FileList^.Count-1) or
  245.     (not Incomplete)) then
  246.   begin
  247.     if CurFile^.OptFlags and coResetAFlag <> 0 then
  248.     begin
  249.       Assign(TargetFile, CurFile^.OrigName^);
  250.       GetFAttr(TargetFile, Attr);
  251.       Attr := Attr and (not Archive);
  252.       SetFAttr(TargetFile, Attr);
  253.       if DosError <> 0 then IOError(CurFile^.OrigName^, erResetAFlag);
  254.     end;
  255.   end;
  256. end;
  257.  
  258. begin
  259.   FileList^.ForEach(@FlushFile);
  260.   if Incomplete then Leave := 1 else Leave := 0;
  261.   while FileList^.Count <> Leave do
  262.     FileList^.AtFree(0);
  263. end;
  264.  
  265. function TFileCopy.CopyFile(const SourceName, TargetName: FNameStr;
  266.   Options: Word): Boolean;
  267. const
  268.   Safety = 4096;
  269. var
  270.   Flush: Boolean;
  271.   SourceFile: File;
  272.   TargetFile: File;
  273.   CurFile: PFileRec;
  274.   RemainingBytes: Longint;
  275.   BytesToXFer: Word;
  276.   DidXFer: Word;
  277.   BufAddr: Pointer;
  278.   CurMaxAvail: Longint;
  279.   SRec: SearchRec;
  280. begin
  281.   CopyFile := False;
  282.  
  283.   { validate the coCopyAOnly flag }
  284.   if Options and coCopyAOnly <> 0 then
  285.   begin
  286.     FindFirst(SourceName, AnyFile, SRec);
  287.     if (DosError = 0) and ((SRec.Attr and Archive) = 0) then Exit
  288.     else IOError(SourceName, erNoFile);
  289.   end;
  290.  
  291.   CurFile := New(PFileRec, Init(SourceName, TargetName));
  292.   CurFile^.Buffers := New(PPtrCollection, Init(5,2));
  293.   if (CurFile = nil) or (CurFile^.Buffers = nil) then
  294.   begin
  295.     InternalError(erOutOfMemory);
  296.     Exit;
  297.   end;
  298.   CurFile^.OptFlags := Options;
  299.   CurFile^.Offset := 0;
  300.   CurFile^.Create := True;
  301.   FileList^.Insert(CurFile);
  302.  
  303.   Offset := 0;
  304.   Incomplete := False;
  305.   IsNewFile := False;
  306.   Base := 0;
  307.  
  308.   repeat
  309.     Flush := False;
  310.  
  311.     FileMode := fmReadOnly;
  312.     Assign(SourceFile, SourceName);
  313.  
  314.     Action := erRetry;
  315.     Result := 1;
  316.     while (Action <> erAbort) and (Result <> 0) do
  317.     begin
  318.       {$I-}
  319.       Reset(SourceFile,1);
  320.       {$I+}
  321.       Result := IOResult;
  322.       if Result <> 0 then
  323.       begin
  324.         if IOError(SourceName, erReadOpen) = erAbort then
  325.         begin
  326.           FileList^.Free(CurFile);
  327.           Exit;
  328.         end;
  329.       end;
  330.     end;
  331.  
  332.     if Incomplete then
  333.     begin
  334.       Seek(SourceFile, Offset-Base);
  335.       CurFile^.Offset := Offset;
  336.       if Incomplete then CurFile^.Create := False;
  337.     end;
  338.  
  339.     Incomplete := False;
  340.  
  341.     CurFile^.FSize := FileSize(SourceFile) - Offset + Base;
  342.     CurMaxAvail := MaxAvail - Safety;
  343.  
  344.     if CurFile^.FSize > CurMaxAvail then
  345.     begin
  346.       CurFile^.FSize := CurMaxAvail;
  347.       Flush := True;
  348.       Incomplete := True;
  349.       CurFile^.Offset := Offset;
  350.     end;
  351.     RemainingBytes := CurFile^.FSize;
  352.  
  353.     repeat
  354.       if RemainingBytes > MaxXFerSize then BytesToXFer := MaxXFerSize
  355.       else BytesToXFer := RemainingBytes;
  356.       GetMem(BufAddr, BytesToXFer);
  357.       CurFile^.Buffers^.Insert(BufAddr);
  358.       BlockRead(SourceFile, BufAddr^, BytesToXFer, DidXFer);
  359.       ReadMsg(SourceName, DidXFer);
  360.       Dec(RemainingBytes, DidXFer);
  361.     until RemainingBytes = 0;
  362.  
  363.     GetFTime(SourceFile, CurFile^.FTime);
  364.     Close(SourceFile);
  365.  
  366.     if Flush then FlushBuffers;
  367.  
  368.   until not Incomplete;
  369.   CopyFile := True;
  370. end;
  371.  
  372. procedure TFileCopy.ReadMsg(const FName: FNameStr; Progress: Longint);
  373. begin
  374.   Writeln('Reading ', FName);
  375. end;
  376.  
  377. procedure TFileCopy.WriteMsg(const FName: FNameStr; Progress: Longint);
  378. begin
  379.   Writeln('Writing ', FName);
  380. end;
  381.  
  382. procedure TFileCopy.ReportError(S: String);
  383. begin
  384.   Writeln(S);
  385. end;
  386.  
  387. function TFileCopy.ErrorMsg(ECode: Integer): String;
  388. begin
  389.   case ECode of
  390.     erWriteOpen   : ErrorMsg := 'Unable to open for write access';
  391.     erReadOpen    : ErrorMsg := 'Unable to open for read access';
  392.     erDiskFull    : ErrorMsg := 'Unable to write to file.  Disk full?';
  393.     erLostFile    : ErrorMsg := 'File never flushed from buffers';
  394.     erNoFile      : ErrorMsg := 'File not found.';
  395.     erRename      : ErrorMsg := 'Unable to rename to final name.';
  396.     erOutOfMemory : ErrorMsg := 'Unable to allocate memory.';
  397.     else ErrorMsg := 'Unknown error.';
  398.   end; { case }
  399. end;
  400.  
  401. end.
  402.